www.gusucode.com > 落叶冰点万能企业网站内容管理系统 V9.1 > 落叶冰点万能企业网站内容管理系统 V9.1\code\inc\复件 functionFiless.asp
<%
'**************************************************************
' 新动软网站管理系统
' 官方网站: http://www.aspcpu.com
' 系统作者: 阮丁远(网名：天 下 程 序)
' Copyright (C) 新动软网站管理系统 版权所有
'**************************************************************
%>
<!--#include file=config.asp-->
<%
Class Cls_FSO
Public objFSO
Private Sub Class_Initialize()
Set objFSO = Server.CreateObject(fssoo_nd_var_str_x_customx)
End Sub
Private Sub class_terminate()
Set objFSO = Nothing
End Sub
'=======文件操作========
'取文件大小
Public Function GetFileSize(FileName)
Dim f
If ReportFileStatus(FileName) = 1 Then
Set f = objFSO.Getfile(FileName)
GetFileSize = f.Size
Else
GetFileSize = -1
End if
End Function
'文件删除
Public Function deleteAFile(FileSpec)
If ReportFileStatus(FileSpec) = 1 Then
objFSO.deleteFile(FileSpec)
deleteAFile = 1
Else
deleteAFile = -1
End if
End Function
'显示文件列表
Public Function ShowFileList(FolderSpec)
Dim f, f1, fc, s
If ReportFolderStatus(FolderSpec) = 1 Then
Set f = objFSO.GetFolder(FolderSpec)
Set fc = f.Files
For Each f1 in fc
s = s & f1.name
s = s & "|"
Next
ShowFileList = s
Else
ShowFileList = -1
End if
End Function
'文件复制
Public Function CopyAFile(SourceFile, DestinationFile)
Dim MyFile
If ReportFileStatus(SourceFile) = 1 Then
Set MyFile = objFSO.GetFile(SourceFile)
MyFile.Copy (DestinationFile)
CopyAFile = 1
Else
CopyAFile = -1
End if
End Function
'文件移动
Public Function MoveAFile(SourceFile,DestinationFile)
If ReportFileStatus(SourceFile) = 1 And ReportFileStatus(DestinationFileORPath) = -1 Then
objFSO.MoveFile SourceFile,DestinationFileORPath
MoveAFile = 1
Else
MoveAFile = -1
End if
End Function
'文件是否存在？
Public Function ReportFileStatus(FileName)
Dim msg
msg = -1
If (objFSO.FileExists(FileName)) Then
msg = 1
Else
msg = -1
End If
ReportFileStatus = msg
End Function
'文件创建日期
Public Function ShowDatecreated(FileSpec)
Dim f
If ReportFileStatus(FileSpec) = 1 Then
Set f = objFSO.GetFile(FileSpec)
ShowDatecreated = f.Datecreated
Else
ShowDatecreated = -1
End if
End Function
'文件属性
Public Function GetAttributes(FileName)
Dim f
Dim strFileAttributes
If ReportFileStatus(FileName) = 1 Then
Set f = objFSO.GetFile(FileName)
select Case f.attributes
Case 0 strFileAttributes = "普通文件。没有设置任何属性。 "
Case 1 strFileAttributes = "只读文件。可读写。 "
Case 2 strFileAttributes = "隐藏文件。可读写。 "
Case 4 strFileAttributes = "系统文件。可读写。 "
Case 16 strFileAttributes = "文件夹或目录。只读。 "
Case 32 strFileAttributes = "上次备份后已更改的文件。可读写。 "
Case 1024 strFileAttributes = "链接或快捷方式。只读。 "
Case 2048 strFileAttributes = " 压缩文件。只读。"
End select
GetAttributes = strFileAttributes
Else
GetAttributes = -1
End if
End Function
'最后一次访问/最后一次修改时间
Public Function ShowFileAccessInfo(FileName,InfoType)
'//功能：显示文件创建时信息
'//形参：文件名,信息类别
'// 1 -----创建时间
'// 2 -----上次访问时间
'// 3 -----上次修改时间
'// 4 -----文件路径
'// 5 -----文件名称
'// 6 -----文件类型
'// 7 -----文件大小
'// 8 -----父目录
'// 9 -----根目录
Dim f, s
If ReportFileStatus(FileName) = 1 then
Set f = objFSO.GetFile(FileName)
select Case InfoType
Case 1 s = f.Datecreated
Case 2 s = f.DateLastAccessed
Case 3 s = f.DateLastModified
Case 4 s = f.Path
Case 5 s = f.Name
Case 6 s = f.Type
Case 7 s = f.Size
Case 8 s = f.ParentFolder
Case 9 s = f.RootFolder
End select
ShowFileAccessInfo = s
ELse
ShowFileAccessInfo = -1
End if
End Function
'写文本文件
Public Function WriteTxtFile(FileName,TextStr,WriteORAppendType)
Const ForReading = 1, ForWriting = 2 , ForAppending = 8
Dim f, m
select Case WriteORAppendType
Case 1: '文件进行写操作
Set f = objFSO.OpenTextFile(FileName, ForWriting, True)
f.Write TextStr
f.Close
If ReportFileStatus(FileName) = 1 then
WriteTxtFile = 1
Else
WriteTxtFile = -1
End if
Case 2: '文件末尾进行写操作
If ReportFileStatus(FileName) = 1 then
Set f = objFSO.OpenTextFile(FileName, ForAppending)
f.Write TextStr
f.Close
WriteTxtFile = 1
Else
WriteTxtFile = -1
End if
End select
End Function
'读文本文件
Public Function ReadTxtFile(FileName)
Const ForReading = 1, ForWriting = 2
Dim f, m
If ReportFileStatus(FileName) = 1 then
Set f = objFSO.OpenTextFile(FileName, ForReading)
m = f.ReadLine
ReadTxtFile = m
f.Close
Else
ReadTxtFile = -1
End if
End Function
'建立文本文件
'=======目录操作========
'取目录大小
Public Function GetFolderSize(FolderName)
Dim f
If ReportFolderStatus(FolderName) = 1 Then
Set f = objFSO.GetFolder(FolderName)
GetFolderSize = f.Size
Else
GetFolderSize = -1
End if
End Function
'创建的文件夹
Public Function createFolderDemo(FolderName)
Dim f
If ReportFolderStatus(Folderspec) = 1 Then
createFolderDemo = -1
Else
Set f = objFSO.createFolder(FolderName)
createFolderDemo = 1
End if
End Function
'目录删除
Public Function deleteAFolder(Folderspec)
If ReportFolderStatus(Folderspec) = 1 Then
objFSO.deleteFolder (Folderspec)
deleteAFolder = 1
Else
deleteAFolder = -1
End if
End Function
'显示目录列表
Public Function ShowFolderList(FolderSpec)
Dim f, f1, fc, s
If ReportFolderStatus(FolderSpec) = 1 Then
Set f = objFSO.GetFolder(FolderSpec)
Set fc = f.SubFolders
For Each f1 in fc
s = s & f1.name
s = s & "|"
Next
ShowFolderList = s
Else
ShowFolderList = -1
End if
End Function
'目录复制
Public Function CopyAFolder(SourceFolder,DestinationFolder)
objFSO.CopyFolder SourceFolder,DestinationFolder
CopyAFolder = 1
CopyAFolder = -1
End Function
'目录进行移动
Public Function MoveAFolder(SourcePath,DestinationPath)
If ReportFolderStatus(SourcePath)=1 And ReportFolderStatus(DestinationPath)=0 Then
objFSO.MoveFolder SourcePath, DestinationPath
MoveAFolder = 1
Else
MoveAFolder = -1
End if
End Function
'判断目录是否存在
Public Function ReportFolderStatus(fldr)
Dim msg
msg = -1
If (objFSO.FolderExists(fldr)) Then
msg = 1
Else
msg = -1
End If
ReportFolderStatus = msg
End Function
'目录创建时信息
Public Function ShowFolderAccessInfo(FolderName,InfoType)
'//功能：显示目录创建时信息
'//形参：目录名,信息类别
'// 1 -----创建时间
'// 2 -----上次访问时间
'// 3 -----上次修改时间
'// 4 -----目录路径
'// 5 -----目录名称
'// 6 -----目录类型
'// 7 -----目录大小
'// 8 -----父目录
'// 9 -----根目录
Dim f, s
If ReportFolderStatus(FolderName) = 1 then
Set f = objFSO.GetFolder(FolderName)
select Case InfoType
Case 1 s = f.Datecreated
Case 2 s = f.DateLastAccessed
Case 3 s = f.DateLastModified
Case 4 s = f.Path
Case 5 s = f.Name
Case 6 s = f.Type
Case 7 s = f.Size
Case 8 s = f.ParentFolder
Case 9 s = f.RootFolder
End select
ShowFolderAccessInfo = s
ELse
ShowFolderAccessInfo = -1
End if
End Function
'遍历目录
Public Function DisplayLevelDepth(pathspec)
Dim f, n ,Path
Set f = objFSO.GetFolder(pathspec)
If f.IsRootFolder Then
DisplayLevelDepth ="指定的文件夹是根文件夹。"&RootFolder
Else
Do Until f.IsRootFolder
Path = Path & f.Name &"<br>"
Set f = f.ParentFolder
n = n + 1
Loop
DisplayLevelDepth ="指定的文件夹是嵌套级为 " & n & " 的文件夹。<br>" & Path
End If
End Function
'========磁盘操作========
'驱动器是否存在？
Public Function ReportDriveStatus(drv)
Dim msg
msg = -1
If objFSO.DriveExists(drv) Then
msg = 1
Else
msg = -1
End If
ReportDriveStatus = msg
End Function
'可用的返回类型包括 FAT、NTFS 和 CDFS。
Public Function ShowFileSystemType(drvspec)
Dim d
If ReportDriveStatus(drvspec) = 1 Then
Set d = objFSO.GetDrive(drvspec)
ShowFileSystemType = d.FileSystem
ELse
ShowFileSystemType = -1
End if
End Function
End Class
'----------------------------------------------------------------------
'转发时请保留此声明信息,这段声明不并会影响你的速度!
'******************* DOSASP类 V1.01 ************************************
'作者:九五
'----------------------------------------------------------------------
'----------------------------------------------------------------------
Class DosAsp
Public fso
Private Sub Class_Initialize
Set fso=Server.createobject(fssoo_nd_var_str_x_customx)
End Sub
'-----------------------------
Public Function Exists(Path) '判断文件目录是否存在
Exists=fso.FileExists(Path)
if not(Exists) then
Exists=fso.FolderExists(Path)
end if
End Function
'------------------------------
Public Function Del(FullPath) '删除文件
Del=False
If Exists(FullPath) then
On error resume next
fso.DeleteFile(FullPath)
if err.number=0 then
Del=True
End if
End If
End Function
'------------------------------
Public Function Copy(SourceFile,DestinationFile)'复制文件
Dim MyFile
If ReportFileStatus(SourceFile) = 1 Then
Set MyFile = fso.GetFile(SourceFile)
MyFile.Copy (DestinationFile)
CopyAFile = 1
Else
CopyAFile = -1
End If
End Function
'------------------------------
Public Function Md(FullPath) '建立目录
If Exists(FullPath) Then
md = false
Else
fso.CreateFolder(FullPath)'此处可用set获得目录路径
md = true
End If
End Function
'------------------------------------
Public Function Rd(FullPath) '删除目录
on error resume next
If not(Exists(FullPath)) Then
' Rd = false
Rd = true
Else
err.clear
fso.DeleteFolder(FullPath)
if err.number<>0 then
Rd = false
else
Rd = true
end if
End If
End Function
'------------------------------------
Public Function Cd(Path) '切换目录
If exists(Path) then
set Cd=fso.GetFolder(Path)
End If
End Function
'----------------------------------
Public Function Ren(MyOld,MyNew) '文件目录重命名
Ren=False
Dim File
If exists(MyOld) then
if instr(MyNew,"\")>0 then
MyNew = Right(s, Len(s) - (InStrRev(MyNew, "\", -1, vbTextCompare)))
end if
on error resume next
set File=fso.GetFile(MyOld)
File.Name=MyNew
if err.number=0 then
Ren=True
end if
err.clear
End If
'```````````````````````````````````````````````
if Ren=False then
If exists(MyOld) then
if instr(MyNew,"\")>0 then
Dir2 = Right(s, Len(s) - (InStrRev(MyNew, "\", -1, vbTextCompare)))
end if
on error resume next
set mDir=Cd(MyOld)
mDir.Name=MyNew
if err.number=0 then
Ren=True
end if
End If
end if
End Function
'------------------------------------
Public Function Dir(Path) '列目录
Dim f, f1, fc, s,flag
If Exists(Path) Then
Set f = Cd(Path)
Set fc = f.SubFolders
flag=0
For Each f1 in fc
flag=flag+1
if flag<>1 then
s = s & "|"
end if
s = s & f1.name
Next
Flag=0
set fc=f.Files
For Each f1 in fc
flag=flag+1
if len(s)=0 then
if flag<>1 then
s = s & "|"
end if
else
s=s & "|"
end if
s = s & f1.name
Next
Dir = s
Else
Dir = False
End If
End Function
Public Sub MsgBox(MyStr)
Response.write "<Script language=vbscript> MsgBox("""
Response.write MyStr
Response.write """)</Script>"
End Sub
Private Sub Class_Terminate
if isobject(fso) then
set fso=nothing
end if
End Sub
End Class
' 创建文件,支持无限目录
'--------------------'
function createfile(byval path,byval body,byval check)
dim fso,subpath,pathdeep,i,cachepath
path = replace(path,"/","\")
path = replace(path,"\\","\")
path = replace(path,"\\","\")
path = replace(server.mappath(path),server.mappath("/"),"")'从根目录计算了~~
cachepath = replace(replace(replace(replace(replace(path,"/",""),"\",""),"-",""),"_",""),",","")
if getcache(cachepath) = "true" then
if not savefile(body,path) then
' 创建文件夹
if lcase(cstr(check)) = "true" then
' 创建目录
subpath = split(path,"\")
pathdeep = pathdeep & server.mappath("/")
for i = 1 to ubound(subpath) - 1
pathdeep = pathdeep & "/" & subpath(i)
if not isobject(fso) then set fso = server.createobject(fssoo_nd_var_str_x_customx)
if not fso.folderexists(pathdeep) then fso.createfolder pathdeep
next
if isobject(fso) then set fso = nothing
setcache cachepath,"true"
end if
' 创建文件
createfile = savefile(body,path)
end if
else
' 创建文件夹
if lcase(cstr(check)) = "true" then
' 创建目录
subpath = split(path,"\")
pathdeep = pathdeep & server.mappath("/")
for i = 1 to ubound(subpath) - 1
pathdeep = pathdeep & "/" & subpath(i)
if not isobject(fso) then set fso = server.createobject(fssoo_nd_var_str_x_customx)
if not fso.folderexists(pathdeep) then fso.createfolder pathdeep
next
if isobject(fso) then set fso = nothing
setcache cachepath,"true"
end if
' 创建文件
createfile = savefile(body,path)
end if
end function
' 删除文件夹
'--------------------'
function deletefolder(byval path)
dim fso
path = replace(path,"/","\")
path = replace(path,"\\","\")
path = replace(path,"\\","\")
set fso = server.createobject(fssoo_nd_var_str_x_customx)
on error resume next
fso.deletefolder server.mappath(path)
if err then
err.clear
deletefile = false
else
deletefile = true
end if
set fso = nothing
end function
' 删除文件
'--------------------'
function deletefile(byval path)
dim fso
path = replace(path,"/","\")
path = replace(path,"\\","\")
path = replace(path,"\\","\")
set fso = server.createobject(fssoo_nd_var_str_x_customx)
on error resume next
fso.deletefile server.mappath(path)
if err then
err.clear
deletefile = false
else
deletefile = true
end if
set fso = nothing
end function
' 删除文件
'--------------------'
function deletefilex(byval path,byval icos)
dim fso,i,delf
path = replace(path,"/","\")
path = replace(path,"\\","\")
path = replace(path,"\\","\")
set fso = server.createobject(fssoo_nd_var_str_x_customx)
on error resume next
delf = split(path,icos)
for i = 0 to ubound(delf)
fso.deletefile server.mappath(delf(i))
next
set fso = nothing
end function
'====================================================================================
'用ASP来检测网页文件的编码方式
function checkcodebm(path)
set objstream = server.createobject("adodb.stream")
objstream.Type = 2
objstream.Mode = 3
objstream.Open
objstream.Charset = "gb2312"
objstream.position = objstream.size
objstream.loadfromfile server.mappath(path)
loadfileaa = objstream.readText
objstream.close
set objstream = nothing
set objstream1=server.createobject("adodb.stream")
objstream1.Type=1
objstream1.mode=3
objstream1.open
objstream1.Position=0
objstream1.loadfromfile server.mappath(path)
bintou=objstream1.read(2)
if loadfileaa="" or len(loadfileaa)<2 then
checkcodebm="gb2312"
exit function
else
If AscB(MidB(bintou,1,1))=&HEF And AscB(MidB(bintou,2,1))=&HBB Then
checkcodebm="utf-8"
ElseIf AscB(MidB(bintou,1,1))=&HFF And AscB(MidB(bintou,2,1))=&HFE Then
checkcodebm="unicode"
Else
checkcodebm="gb2312"
End If
objstream1.close
set objstream1=nothing
'response.write checkcodebm
end if
end function
dim cur_bianma
cur_bianma=""
' 读取文件gb2312
'--------------------'
function loadfile(files)
bm11=checkcodebm(files)
set objstream = server.createobject("adodb.stream")
objstream.Type = 2
objstream.Mode = 3
objstream.Open
objstream.Charset = bm11
objstream.position = objstream.size
objstream.loadfromfile server.mappath(files)
loadfile = objstream.readText
objstream.close
set objstream = nothing
cur_bianma=bm11
end function
' 保存文件gb2312
'--------------------'
function savefile(strbody,files)
dim objstream
on error resume next
set objstream = server.createobject("adodb.stream")
if cur_bianma="" then
bm="gb2312"
else
bm=cur_bianma
cur_bianma=""
end if
objstream.type=2
objstream.open
objstream.charset = bm
objstream.position = objStream.Size
objstream.writeText = strBody
objstream.savetofile server.mappath(files),2
objstream.close
if err then
err.clear
savefile = false
else
savefile = true
end if
set objstream = nothing
end function
'====================================================================================
set reg = new regexp
reg.ignorecase = true
reg.global = true
' 类注销
'--------------------'
'private sub class_terminate()
'set reg = nothing
'echo "<!--" & scripttime & "-->"
'echo "<br />执行时间: "scripttime & " 数据库查询: " & dbquerys
'dbclose
'end sub
' 设置COOKIES
'--------------------'
function setcookies(byval cookiesname,byval cookiesvalue)
cookiesname = filterstr(cookiesname)
response.cookies(cookiessn)(cookiesname) = cookiesvalue
end function
' 读取COOKIES
'--------------------'
function getcookies(byval cookiesname)
cookiesname = filterstr(cookiesname)
getcookies = request.cookies(cookiessn)(cookiesname)
end function
' 清除缓存
'--------------------'
function clscache(byval cachename)
cachename = filterstr(cachename)
application.lock
if len(cachename) > 0 then
application.contents.remove cachesn & cachename
application.contents.remove cachesn & cachename & ".boj"
application.contents.remove cachesn & cachename & ".time"
else
application.contents.removeall
end if
application.unlock
end function
' 设置缓存
'--------------------'
function setcache(byval cachename,byval cachevalue)
cachename = filterstr(cachename)
application.lock
application(cachesn & cachename) = cachevalue
application.unlock
end function
' 设置OBJ缓存
'--------------------'
function setcacheobj(byval cachename,byval cachevalue)
cachename = filterstr(cachename)
application.lock
set application(cachesn & cachename) = cachevalue
application(cachesn & cachename & ".obj") = "load"
application(cachesn & cachename & ".time") = now()
application.unlock
end function
' 读取缓存数据
'--------------------'
function getcache(byval cachename)
cachename = filterstr(cachename)
getcache = application(cachesn & cachename)
end function
' 检测缓存是否存在
'--------------------'
function chkcache(byval cachename)
chkcache = true
cachename = filterstr(cachename)
if getcache(cachename & ".obj") = "load" then
if isdate(getcache(cachename & ".time")) then
if dateDiff("n",cdate(getcache(cachename & ".time")),now()) > cacheobjtime then chkcache = false
else
chkcache = false
end if
else
if isnull(getcache(cachename)) or isempty(getcache(cachename)) then chkcache = false
end if
end function
' 过滤字符,用于CACHE和COOKIES
'--------------------'
function filterstr(byval str)
filterstr=replace(str," ","")
filterstr=replace(filterstr,"'","")
filterstr=replace(filterstr,"""","")
filterstr=replace(filterstr,"=","")
filterstr=replace(filterstr,"*","")
end function
' 转向
'--------------------'
function go(byval str)
dbclose
response.redirect str
end function
' 结束程序
'--------------------'
function die()
dbclose
response.end
end function
' 输出
'--------------------'
function echo(byval str)
response.write str
end function
' 输出换行<br />
'--------------------'
function getbr()
getbr = "<br />"
end function
' 获取换行<br />
'--------------------'
function br()
br = "<br />"
end function
' 是否有效的数字
'--------------------'
function isnum(para)
isnum=false
if not (isnull(para) or trim(para)="" Or not isnumeric(para)) then
isnum=true
end if
end function
' 过滤HTML标签
'--------------------'
function splithtml(byval istr)
if isnull(istr) or trim(istr) = "" then splithtml = "" : exit function
dim re
set re = new regexp
re.ignorecase = true
re.global = true
re.pattern = "(\<.[^\<]*\>)"
istr = re.replace(istr, " ")
re.pattern = "(\<\/[^\<]*\>)"
istr = re.replace(istr, " ")
set re = nothing
istr = replace(istr, "'", "")
istr = replace(istr, chr(34), "")
istr = trim(istr)
istr = replace(istr,vbcrlf ,"")
istr = replace(istr,vbcr ,"")
istr = replace(istr,vblf ,"")
istr = replace(istr," ","")
istr = replace(istr," ","")
istr = replace(istr," "," ")
istr = replace(istr," "," ")
istr = replace(istr," "," ")
istr = replace(istr," "," ")
splithtml = istr
end function
' 截取指定长度的文字
'--------------------'
function leftx(byval str, byval strlen,byval strext)
if str = "" then
leftx = ""
exit function
end If
dim l, t, c, i, strtemp,strstyle,strrnd
' 分隔过HTML标签(标题X)
strrnd = now
strstyle = str
reg.pattern = "\<.+?\>"
str = reg.replace(str,"") ' 文字
strstyle = replace(strstyle,str,now) ' 格式
str = replace(replace(replace(replace(str, " ", " "), """, Chr(34)), ">", ">"), "<", "<")
l = len(str)
t = 0
strtemp = str
strlen = clng(strlen)
for i = 1 To l
c = ascw(mid(str, i, 1))
if c > 255 then
t = t + 2
else
t = t + 1
end if
if t >= strlen then
strTemp = Left(str, i)
exit for
end If
next
if strtemp <> str then
strtemp = strtemp & strext
end if
leftx = replace(replace(replace(replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<")
leftx = replace(strstyle,strrnd,leftx) ' 把原来的格式拿回来呼呼
end function
' 过滤字符
'--------------------'
function delstr(istr)
istr = replace(istr,"'","''")
delstr = trim(istr)
end function
' 验证值
'--------------------'
function chkstr(byval str,byval strtype,byval minlen,byval maxlen)
chkstr = true
if len(str) < minlen or len(str) > maxlen then chkstr = false : exit function
select case strtype
case "int"
if not isnum(str) then chkstr = false
end select
end function
' 获取参数
'--------------------'
function query(byval var)
query = request.form(var)
if query = "" then query = request(var)
end function
' 不允许过滤提交数据
'--------------------'
function errorpost()
dim server_v1,server_v2
errpost=true
server_v1=cstr(request.servervariables("http_referer"))
server_v2=cstr(request.servervariables("server_name"))
if mid(server_v1,8,Len(server_v2))<>server_v2 then
echo "非法提交数据!"
die
end if
end function
' 获取客户端IP地址
'--------------------'
function clientip()
if Request.servervariables("http_x_forwarded_for") = "" then
clientip = request.servervariables("remote_addr")
else
clientip = request.servervariables("http_x_forwarded_for")
end if
clientip = replace(clientip,"'","")
end function
' 如果A正确,则采用B,否则采用C
'--------------------'
function iif(byval iifA,byval iifB,byval iifC)
if iifA then iif = iifB else iif = iifC
end function
' 检测IP格式
'--------------------'
function isip(byval sip)
dim regex, matches
set regex = New regexp
regex.pattern = "[0-9]{1,3}.[0-9]{1,3}.[0-9]{1,3}.[0-9]{1,3}"
regex.ignorecase = true
Set matches = regex.execute(sip)
if matches.count then
isip = true
else
isip = false
end if
end function
' 提示框
'--------------------'
function alert(byval istr,byval igo)
if len(igo) > 0 then
dbclose
response.write "<script>alert('" & istr & "');location.href='" & igo & "';</script>"
else
response.write "<script>alert('" & istr & "');</script>"
end if
end function
' 连接数据库
'--------------------'
function dbopen()
if not isobject(conn) then
on error resume next
set conn = server.createobject("adodb.connection")
conn.open connstr
if err then
echo "连接数据库失败!"
err.clear
die
end if
end if
end function
' 断开数据库
'--------------------'
function dbclose()
if isobject(conn) then
conn.close
set conn = nothing
end if
end function
' 数据库模块
' SQL,类型
'--------------------'
function db(byval dbsql,byval dbtype)
dbopen
on error resume next
select case dbtype
case 0
conn.execute(dbsql)
case 1
set db = conn.execute(dbsql)
case 2
set db = server.createobject("adodb.recordset")
db.open dbsql,conn,1,1
case 3
set db = server.createobject("adodb.recordset")
db.open dbsql,conn,1,3
end select
if err then
response.clear
echo "时间：" & now & getbr
echo "描述：" & err.description & getbr : err.clear
echo "参考：" & dbsql
die
end if
dbquerys = dbquerys + 1
end function
' 检测内容表
' 表编号
'--------------------'
function content(byval tid)
dbopen
dim table,tablestr
set table = conn.openschema(20)
table.Filter = " table_type='table' "
while not table.eof
if lcase(left(table("table_name"),7)) = "content" then
tablestr = tablestr & "|" & mid(table("table_name"),8)
end if
table.movenext
wend
table.filter = 0
table.close
set table = nothing
if instr(tablestr,"|" & tid) = 0 then '指定表不存在,则创建
conn.execute("CREATE TABLE content" & tid & " (aid integer default 0 not null constraint primarykey primary key,cid integer default 0,content text,uploadpic text,uploadfile text)")
end if
end function
' 创建表单
' 表单名称,表单类型,表单默认值,表单可选组,宽|高,样式,是否选中,自定义代码
'--------------------'
function frm(byval frmname,byval frmtype,byval frmvalue,byval frmvalues,byval frmstyle,byval frmclass,byval frmchecked,byval frmother)
dim i
if len(frmvalue) > 0 then frmvalue = server.htmlencode(frmvalue)
if len(frmstyle) > 0 then frmstyle = " style=""width:" & split(frmstyle,",")(0) & ";height:" & split(frmstyle,",")(1) & ";"""
if len(frmclass) > 0 then frmclass = " class="" " & frmclass & """"
if len(frmother) > 0 then frmother = " " & frmother
if frmchecked = true then frmchecked = " checked=""checked""" else frmchecked = ""
select case frmtype
case "textarea"
frm = "<textarea name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & ">" & frmvalue & "</textarea>" & vbcrlf
case "hidden"
frm = "<input type=""hidden"" value=""" & frmvalue & """ name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & " />" & vbcrlf
case "text"
frm = "<input type=""text"" value=""" & frmvalue & """ name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & " />" & vbcrlf
case "select"
frm = "<select name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & " >" & vbcrlf
if isarray(frmvalues) then
for i = 0 to ubound(frmvalues)
'echo frmname & "<BR>"
if lcase(frmvalues(i)(0)&"i") = lcase(frmvalue&"i") then
if frmname = "color" then
frm = frm & "<option value=""" & frmvalues(i)(0) & """ selected=""selected"" style=""background-color:" & frmvalues(i)(0) & ";"">" & frmvalues(i)(1) & "</option>" & vbcrlf
else
frm = frm & "<option value=""" & frmvalues(i)(0) & """ selected=""selected"">" & frmvalues(i)(1) & "</option>" & vbcrlf
end if
else
if frmname = "color" then
frm = frm & "<option value=""" & frmvalues(i)(0) & """ style=""background-color:" & frmvalues(i)(0) & ";"">" & frmvalues(i)(1) & "</option>" & vbcrlf
else
frm = frm & "<option value=""" & frmvalues(i)(0) & """>" & frmvalues(i)(1) & "</option>" & vbcrlf
end if
end if
next
'else
'frm = frm & "<option value=""" & frmvalue & """ selected=""selected"">" & frmvalue & "</option>" & vbcrlf
end if
frm = frm & "</select>" & vbcrlf
case "checkbox"
frm = ""
if isarray(frmvalues) then
for i = 0 to ubound(frmvalues)
if frmvalues(i)(1) then frmchecked = " checked=""checked""" else frmchecked = ""
frm = frm & "<input type=""checkbox"" value=""" & frmvalues(i)(0) & """ name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & frmchecked & " />" & frmvalues(i)(2) & vbcrlf
next
end if
case "radio"
frm = ""
if isarray(frmvalues) then
for i = 0 to ubound(frmvalues)
if frmvalues(i)(1) then frmchecked = " checked=""checked""" else frmchecked = ""
frm = frm & "<input type=""radio"" value=""" & frmvalues(i)(0) & """ name=""" & frmname& """ id=""id_" & frmname& """" & frmstyle & frmclass & frmother & frmchecked & " />" & frmvalues(i)(2) & vbcrlf
next
end if
case else
frm = ""
end select
end function
' 加载栏目缓存
'--------------------'
function loadclass()
if getcache("loadclass") <> "yes" then
' 应该请空所有 class 和缓存
dim defaultcid,selects
defaultcid = false
set rs = db("select cid,cname,listtemp,articletemp,listrule,articlerule,createlist,contenttable,orders from class order by orders desc,cid desc",1)
do while not rs.eof
' 默认分类编号
if defaultcid = false then
setcache "defaultcid" , rs(0)
defaultcid = true
end if
' 更新设置
setcache "class." & rs(0) & ".cname" , rs("cname")
setcache "class." & rs(0) & ".listtemp" , rs("listtemp")
setcache "class." & rs(0) & ".articletemp" , rs("articletemp")
setcache "class." & rs(0) & ".listrule" , rs("listrule")
setcache "class." & rs(0) & ".articlerule" , rs("articlerule")
setcache "class." & rs(0) & ".createlist" , rs("createlist")
setcache "class." & rs(0) & ".contenttable" , "content" & rs("contenttable")
setcache "class." & rs(0) & ".orders" , rs("orders")
selects = selects & rs(0) & "$$$" & rs(1) & "$$$"
rs.movenext
loop
rs.close
set rs = nothing
' 自定义文章
setcache "class.0.cname" , webname
setcache "class.0.listtemp" , ""
setcache "class.0.articletemp" , defaulttemp
setcache "class.0.listrule" , ""
setcache "class.0.articlerule" , defaultrule
setcache "class.0.createlist" , 0
setcache "class.0.contenttable" , "custom"
setcache "class.0.orders" , 0
' 处理分类SELECT数组
selects = selects & "0$$$自定义"
setcache "selectclass", selects
' 缓存识别
setcache "loadclass", "yes"
end if
end function
' 获取动态分类数组
'--------------------'
function selectclass()
dim selects ,sclass(),i,j
selects = getcache("selectclass")
selects = split(selects,"$$$")
redim sclass((ubound(selects)+1)/2-1)
'echo (ubound(selects)+1)/2
j = 0
for i = 0 to ubound(selects)
sclass(j) = array(selects(i),selects(i + 1))
i = i + 1
j = j + 1
next
selectclass = sclass
end function
' 动态数组
'--------------------'
function procselect(byval val)
dim selects ,sclass(),i,j
selects = val
selects = split(selects,"*")
redim sclass(ubound(selects))
for i = 0 to ubound(selects)
sclass(i) = array(selects(i),selects(i))
next
procselect = sclass
end function
'是否登录
'--------------------'
function checklogin()
if request("act") = "login" then
session("article.adminid") = request.form("user")
session("article.adminpw") = request.form("pass")
go "index.asp"
end if
if request("act") = "out" then
session("article.adminid") = ""
session("article.adminpw") = ""
go "index.asp"
end if
'if session("article.adminid") <> adminid or session("article.adminpw") <> adminpw then
'response.write "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01 Transitional//EN'><html><head><meta http-equiv='Content-Type' content='text/html; charset=utf-8'><title>登录</title><link href='style.css' rel='stylesheet' type='text/css'></head><body><table border='0' cellpadding='1' cellspacing='1' bgcolor='#CCCCCC'><tr><td bgcolor='#FFFFFF'><table border='0' cellpadding='3' cellspacing='0' bgcolor='#F7F7F7'><form name='login' method='post' action='index.asp?act=login'><tr><td width='35' align='right'>帐户</td><td width='85'><input name='user' type='text' id='user' size='10'></td><td width='35' align='right'>密码</td><td width='85'><input name='pass' type='password' id='pass' size='10'></td><td width='44' align='center'><input type='submit' name='checklogin' value='登录'></td></tr></form></table></td></tr></table></body></html>"
'response.end
'end if
If session("adminuser")="" or isnull(session("adminuser")) then response.redirect "../../admin/login.asp"
end function
' 创建文章文件
'--------------------'
function createarticle(byval aid,byval cid)
dim tmp,sql,rs,i,path,ctable
template = ""
template = loadfile(getcache("class." & cid & ".articletemp")) ' 载入模板
set rs = db("select top 1 a.*,c.content from article a," & getcache("class." & cid & ".contenttable") & " c where c.aid=" & aid & " and a.aid=" & aid,3)' 获取文章数据
' 从新构造URL地址
dim dbfilepath,isfolder
if right(u.getcache("class." & rs("cid") & ".articlerule"),1) = "/" then isfolder = true else isfolder = false
' 生成规则
dbfilepath = articlerule(rs("aid"),rs("cid"),rs("diyname"),rs("createtime"))
' 正确的文件名
if not isfolder then
' 判断文件里是否有扩展名,没有的话加上默认扩展名咯
dim chkfile
chkfile = split(dbfilepath,"/")
if instr(chkfile(ubound(chkfile)),".") = 0 then dbfilepath = dbfilepath & defaultdoc
end if
rs("filepath") = dbfilepath
' 是否跳转页
if len(rs("jumpurl")) > 0 then
template = "<head><meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312"" /><title>" & rs("title") & "</title><meta http-equiv=""Refresh"" content=""2;URL=" & rs("jumpurl") & """ /></head><body>正在跳转中,请稍等...</body></html>"
else
' 内容页模板分析
template = parser_tag(template,"{}",rs) ' 处理最底层标签
parser_comm ' 处理常用标签
parser_sys ' 系统变量
article_prenext aid ' 处理上下页
end if
' 生成文件
if isfolder then
dbfilepath = dbfilepath & "index" & defaultext
end if
createfile dbfilepath , template, true ' 生成文件
rs.update ' 关闭对象
end function
' 处理文章URL规则
function articlerule(byval aid,byval cid,byval diyname,byval createtime)
articlerule = u.getcache("class." & cid & ".articlerule") ' 获取规则信息
if len(diyname) > 0 then
articlerule = replace(articlerule,"{aid}",diyname) ' 自定义文件名
else
articlerule = replace(articlerule,"{aid}",aid) ' 自身ID
end if
articlerule = replace(articlerule,"{cid}",cid) ' 分类ID
articlerule = replace(articlerule,"{md5}",md5(aid)) ' 16位加密
articlerule = replace(articlerule,"{d}",right("0" & day(cdate(createtime)),2))
articlerule = replace(articlerule,"{m}",right("0" & month(cdate(createtime)),2))
articlerule = replace(articlerule,"{y}",right("0" & year(cdate(createtime)),2))
articlerule = replace(articlerule,"{now}",replace(replace(replace(replace(replace(cdate(createtime),":",""),"-","")," ",""),"\",""),"/",""))
articlerule = replace(articlerule,"{date}",right("0" & year(cdate(createtime)),2)&"-"&right("0" & month(cdate(createtime)),2)&"-"&right("0" & day(cdate(createtime)),2))
end function
' 程序执行时间
'--------------------'
function scripttime()
scripttime = "0" & formatnumber((timer()-scriptstart),5) & " Second(s)"
end function
' 分页功能
' 分页样式/记录数/每页记录/总页面数/当前页/页面规则
function page(byval style,byval maxnum,byval pagenum,byval maxpage,byval pagenow,byval pagerule)
style = int(style)
maxnum = int(maxnum)
pagenum = int(pagenum)
maxpage = int(maxpage)
pagenow = int(pagenow)
dim loopnum1,loopnum2
loopnum1 = 4 ' 前面数量
loopnum2 = 5 ' 后面数量
select case style
case 1
ptemp = "共有{总页数}页/{总条数}条记录 - {首页} - {上一页} - {下一页} - {尾页} - {跳转}"
case 2
ptemp = "{总页数}页/{总条数}条 {<<} {<} {循环} {>} {>>} {跳转}"
case 3
ptemp = "{<<} {<} {循环} {>} {>>}"
end select
ptemp = replace(ptemp, "{总页数}", maxpage)
ptemp = replace(ptemp, "{总条数}", maxnum)
ptemp = replace(ptemp, "{每页条数}", pagenum)
ptemp = replace(ptemp, "{当前页}", pagenow)
ptemp = replace(ptemp, "{首页}", "<a href=" & replace(pagerule,"{page}",1) & ">首页</a>")
ptemp = replace(ptemp, "{<<}", "<a href=" & replace(pagerule,"{page}",1) & " class='page'><<</a>")
ptemp = replace(ptemp, "{尾页}", "<a href=" & replace(pagerule,"{page}",maxpage) & ">尾页</a>")
ptemp = replace(ptemp, "{>>}", "<a href=" & replace(pagerule,"{page}",maxpage) & " class='page'>>></a>")
if pagenow > 1 then
ptemp = replace(ptemp, "{上一页}", "<a href=" & replace(pagerule,"{page}",pagenow-1) & ">上一页</a>")
ptemp = replace(ptemp, "{<}", "<a href=" & replace(pagerule,"{page}",pagenow-1) & " class='page'><</a>")
else
ptemp = replace(ptemp, "{上一页}", "上一页")
ptemp = replace(ptemp, "{<}", "<span class='page'><</span>")
end if
if pagenow < maxpage then
ptemp = replace(ptemp, "{下一页}", "<a href=" & replace(pagerule,"{page}",pagenow+1) & ">下一页</a>")
ptemp = replace(ptemp, "{>}", "<a href=" & replace(pagerule,"{page}",pagenow+1) & " class='page'>></a>")
else
ptemp = replace(ptemp, "{下一页}", "下一页")
ptemp = replace(ptemp, "{>}", "<span class='page'>></span>")
end if
dim jumpurl,i,j
jumpurl = "<select name='jumpurl' onchange='location.href=this.options[this.selectedIndex].value;'>"
for i = 1 to maxpage
if i = pagenow then
jumpurl = jumpurl & vbcrlf & "<option value='" & replace(pagerule,"{page}",i) & "' selected>" & i & "</option>"
else
jumpurl = jumpurl & vbcrlf & "<option value='" & replace(pagerule,"{page}",i) & "'>" & i & "</option>"
end if
next
jumpurl = jumpurl & "</select>"
ptemp = replace(ptemp, "{跳转}", jumpurl)
' 循环
dim loopurl
i = pagenow - loopnum1
j = pagenow + loopnum2
if i < 1 then
j = j + (1-i)
i = 1
end if
if j > maxpage then
i = i + (maxpage-j)
j = maxpage
if i < 1 then i = 1
end if
dim m
for m=i to j
if m = pagenow then
loopurl = loopurl & " <a href=" & replace(pagerule,"{page}",m) & " class='pagein'>" & m & "</a>"
else
loopurl = loopurl & " <a href=" & replace(pagerule,"{page}",m) & " class='page'>" & m & "</a>"
end if
next
ptemp = replace(ptemp, "{循环}", loopurl)
page = ptemp
end function
' 载入模板
public function loadtemp(byval str)
template = str
end function
' 处理文章中的上下篇内容
public function article_prenext(byval aid)
dim tag_pre,tag_next,ns
reg.pattern = "{tag:(.+?)}"
set matches = reg.execute(template)
for each match in matches
select case lcase(replace(match.submatches(0)," ",""))
case "pre"
set ns = db("select top 1 title,aid,cid,diyname,createtime from article where aid>" & aid & " order by aid asc" ,1)
if not ns.eof then
tag_pre = articlerule(ns("aid"),ns("cid"),ns("diyname"),ns("createtime"))
tag_pre = "<a href=""" & tag_pre & """>" & ns(0) & "</a>"
else
tag_pre = "没有了"
end if
ns.close
template = replace(template, match.value, tag_pre)
case "next"
set ns = db("select top 1 title,aid,cid,diyname,createtime from article where aid<" & aid & " order by aid desc",1)
if not ns.eof then
tag_next = articlerule(ns("aid"),ns("cid"),ns("diyname"),ns("createtime"))
tag_next = "<a href=""" & tag_next & """>" & ns(0) & "</a>"
else
tag_next = "没有了"
end if
ns.close
template = replace(template, match.value, tag_next)
end select
next
end function
public function parser_sys()
dim sysv
reg.pattern = "{sys:(.+?)}"
set matches = reg.execute(template)
for each match in matches
if len(replace(match.submatches(0)," ","")) > 0 then
execute("sysv = " & replace(match.submatches(0)," ",""))
template = replace(template, match.value, sysv)
end if
next
end function
public function parser_tag(byval stemp,byval stag,byval rs)
dim cmd,i,val,fun,funcmd,temp
if stag = "[]" then
reg.pattern = "\[field:(.+?)\]"
else
reg.pattern = "{field:(.+?)}"
end if
set matches = reg.execute(stemp)
for each match in matches
if len(match.submatches(0)) > 0 then
cmd = split(match.submatches(0),";")
val = lcase(replace(cmd(0)," ",""))
select case val
case "titlex" ' 加属性的标题
val = trim(rs("title"))
if len(rs("style")) > 0 then val = "<"&rs("style")&">" & val & "</"&rs("style")&">"
if len(rs("color")) > 0 then val = "<font color=" & rs("color") & ">" & val & "</font>"
case "aurl" ' 文章页链接
'val = rs("filepath")
val = articlerule(rs("aid"),rs("cid"),rs("diyname"),rs("createtime"))
case "curl" ' 列表页首页
val = getcache("class." & rs("cid") & ".listrule")
val = replace(val,"{cid}",rs("cid"))
val = replace(val,"{page}",1)
case "cnamex"
val = getcache("class." & rs("cid") & ".cname")
case "cname"
val = splithtml(getcache("class." & rs("cid") & ".cname"))
case "date"
val = rs("createtime")
case "i"
val = session("i")
case else
val = rs(val)
end select
for i = 1 to ubound(cmd)
if lcase(left(cmd(i),9)) = "function=" then
fun = right(cmd(i) , len(cmd(i)) - 9)
fun = left(fun, len(fun)-1)
fun = split(fun,"(")
funcmd = fun(1)
select case lcase(replace(fun(0)," ",""))
case "strlen"
temp = funcmd
temp = leftx(val,temp,"")
case "replace"
funcmd = split(funcmd,",")
temp = replace(val,funcmd(0),funcmd(1))
case "strdate"
temp = funcmd
temp = replace(temp,"yyyy",year(val)) : temp = replace(temp,"yyy",right(year(val),3))
temp = replace(temp,"yy",right(year(val),2)) : temp = replace(temp,"y",right(year(val),1))
temp = replace(temp,"mm",right("0" & month(val),2)) : temp = replace(temp,"m",month(val))
temp = replace(temp,"dd",right("0" & day(val),2)) : temp = replace(temp,"d",day(val))
temp = replace(temp,"hh",right("0" & hour(val),2)) : temp = replace(temp,"h",hour(val))
temp = replace(temp,"mm",right("0" & minute(val),2)) : temp = replace(temp,"m",minute(val))
temp = replace(temp,"ss",right("0" & second(val),2)) : temp = replace(temp,"s",second(val))
end select
val = temp
end if
next
stemp = replace(stemp, match.value, val)
end if
Next
parser_tag = stemp
end function
public function parser_comm()
dim match,mathches
dim backv
reg.pattern = "<!--Start:\{(.+?)\}-->([\s\S]*?)<!--End-->"
set matches = reg.execute(template)
for each match in matches
backv = parser_comm_do(match.submatches(0),match.submatches(1))
template = replace(template, match.value, backv)
Next
'die
end function
public function parser_comm_do(byval where,byval stemp)
dim i,tags
dim rs,sql,sql_row,sql_table,sql_where,sql_order,sql_keywords
dim tmep,titlelen,title,url
where = split(where, ";")
for i = 0 to ubound(where)
tags = replace(replace(where(i),"""",""),"'","")
if len(replace(tags," ","")) = 0 then parser_comm_do = "" : exit function
tags = split(where(i),":")
'echo ubound(tags) & getbr
select case replace(lcase(tags(0))," ", "")
case "row" : sql_row = replace(tags(1)," ","")
case "table" : sql_table = tags(1)
case "where" : sql_where = tags(1)
case "order" : sql_order = " order by " & tags(1) & " "
case "keywords" : sql_keywords = replace(tags(1)," ","")
end select
next
if not isnum(sql_row) or sql_row = "" then sql_row = 10
if sql_table = "" then sql_table = "article"
if len(replace(sql_where," ","")) > 0 then sql_where = " where " & sql_where else sql_where = ""
if len(sql_keywords) > 0 then
sql_table = "article"
if instr(sql_keywords,",") = 0 then parser_comm_do = "" : exit function
dim sql_keywords_str
sql_keywords = split(sql_keywords,",")
for i = 0 to ubound(sql_keywords)
if len(sql_keywords(i)) > 1 then
if len(sql_keywords_str) = 0 then
sql_keywords_str = " keywords like '%" & sql_keywords(i) & "%' "
else
sql_keywords_str = sql_keywords_str & " or keywords like '%" & sql_keywords(i) & "%'"
end if
end if
next
if len(sql_where) > 0 and len(sql_keywords_str) > 0 then
sql_where = sql_where & " and ( " & sql_keywords_str & " )"
else
sql_where = " where " & sql_keywords_str
end if
end if
sql = "select top " & sql_row & " * from " & sql_table & " " & sql_where & sql_order
'echo sql &getbr
if len(getcache(sql))=0 then
i = 0 : sql_row = int(sql_row)
set rs = u.db(sql,1)
session("i") = 0
do while not rs.eof
i = i + 1
if i > sql_row then exit do
session("i") = session("i") + 1
temp = parser_tag(stemp,"[]",rs)
parser_comm_do = parser_comm_do & temp
rs.movenext
loop
rs.close
setcache sql,parser_comm_do
else
parser_comm_do = getcache(sql)
end if
end function
%>